perm filename PT2.3[MSS,LCS] blob sn#238787 filedate 1976-10-05 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		SUBROUTINE PT2
C00019 ENDMK
C⊗;
	SUBROUTINE PT2
	INTEGER VALID
	DIMENSION VALID(6),NBAR(36)
	DATA QLINE/140.0/,HX/2./,VALID/1,4,8,2,3,-2/,SLSP/11.0/
C  QLINE=BASIC LINE LENGTH, HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.

C  ADD MORE TO VALID LATER *****
	COMMON /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG,JPG,BRACK,
	1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4)
	COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
	COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1)
	COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
	1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1)
	EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
	1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(80)),(NDPY,IV(81))
CC	1,(RSTF,RSTFAC(100))
C  TRNSP'S Bb, F, BBb, A, G, Eb.
	NAMQ='AAAAA'
	LL=0
	NBAR(1)=0
5	FORMAT(F,2I)
	IF(RS.NE.'OLD')GO TO 2000
	CALL GETFIL('PARTS')
	CALL FASTIN(RSTFAC,128)
	CALL FASTIN(KPN,JJ2)
	CALL FASTIN(Q,JPQ)
2000	TYPE 144
144	FORMAT(' STAFF SIZE, TRANSP.  '$)
	ACCEPT 5,RSTJ2,LL
	IF(MOD(LL,7).EQ.0)GO TO 140
	DO 40 L=1,6
40	IF(LL.EQ.VALID(L))GO TO 140
	TYPE 240
	GO TO 2000
240	FORMAT(' THIS TRANSP NOT OFFERED')
140	IF(IPG)GO TO 41
	IF(RSTJ2.EQ.0)GO TO 41
	RA=RSTJ2/RPSZ(1)
	DO 141 K=1,JPG
141	RPSZ(K)=RPSZ(K)*RA
	
41	IF(RSTJ2.EQ.0)RSTJ2=.9
	L=JJ2-2
	TR=LL
	IF(LL.NE.0)CALL TRNSP(L,TR)
	I=L
	KK=1
C  FOUND A BAR LINE
	ENDLN=ENDL(JJ)
C  FUNCTION ENDL(JJ) (IN FAIL) DOES ALL ABOVE

	NA=1000
	N=0
	TYPE 90,JJ
	RA=0
90	FORMAT(' NUMBER OF BARS PER LINE: TOTAL BAR LINES='I3/)
	ZLINE=QLINE
9	KL=0
	XLINE=ZLINE
	J=0
	LL=0
	DO 8 K=1,JJ
	IF(RN(K).LT.XLINE)GO TO 8
	KP=K-KL
C  NUMBER OF BARS, THIS LINE
CC	TYPE 89,KP
	KL=K
	J=J+1
	IF(IV(J).NE.KP)LL=-1
	IV(J)=KP
	XLINE=RN(K)+ZLINE
	IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
8	CONTINUE
	IF(LL)TYPE 108,RA,(IV(K),K=1,J)
	IF(RT)GO TO 105
108	FORMAT(F6.2,8(3I3,1X))
CC	TYPE 108
CC108	FORMAT(/)
CC89	FORMAT('+',I3,$)
	IF(J.GT.NA)GO TO 107
	IF(N.EQ.0)GO TO 105
C  SKIP IF FIRST TIME
	IF(N.NE.KP)GO TO 106
	IF(J.EQ.NA)GO TO 105
106	RT=.05
C SHRINK OR EXPAND?
	RA=RA+RT
	ZLINE=QLINE*RS/RA
	GO TO 9
1107	TYPE 111,KA
107	FORMAT(' CAN''T DO IT!')
	TYPE 107
105	TYPE 104,J
104	FORMAT(I4,' LINES - OR TYPE N1, N2 --'$)
	KA=0
	ACCEPT 5,RA,N,KL
C  TYPE 0,n  TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
	IF(KL.NE.0)GO TO 110
C  FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE
C NO MORE THAN 36 NUMS, INCLUDING 0S (FOR PAGE MARKS)
	IF(RA.EQ.0)GO TO 11
	IF(ZLINE.EQ.QLINE)RS=J
	NA=RA
	RT=NA-RA
	IF(RT)GO TO 109
	RA=RA-.6
C  CHECK THIS ↑↑↑ NUMBER!
	IF(N.EQ.0)GO TO 90
109	ZLINE=QLINE*RS/RA
	GO TO 9

111	FORMAT(36I)
110	REREAD 111,NBAR
911	DO 112 K=36,1,-1
	KP=NBAR(K)
	KA=KA+KP
112	IF(KP.EQ.0.AND.KA.EQ.0)KL=K
	IF(KA.NE.JJ)GO TO 1107
C  MISMATCH!
	N=26-2*MOD(KL-1,12)
	IF(N.EQ.26)N=0
C  TO SPACE OUT STAVES VERTICALLY

11	RA=0
	IF(IPG)GO TO 811
	IF(NBAR(1).NE.0)GO TO 811
	DO 711 K=1,36
	IF(K.GT.J)IV(K)=0
711	NBAR(K)=IV(K)
	GO TO 911
811	JEND=-1
	XLINE=ZLINE
	CLEF=-99
	JSLUR=0
	LC=1
	SIG=CLEF
	HX=2
	SP=2.45
C  DEFAULT VERT. SPACE UNITS
	IF(N.EQ.0)GO TO 100
C  SPACED OUT DEPENDING ON NUM OF LINES
	HX=N
	RSTFAC(96)=0
C  MUST BE 0 IN MS TO MAKE DISPLAY
	SP=SP+(HX-2.)*.11
100	KL=1
	IF(JEND.EQ.0)GO TO 1000
103	FORMAT(' TYPE OUTPUT FILE NAME  ',$)
102	FORMAT(A5)
	TYPE 103
	ACCEPT 102,NAMX
	IF(NAMX.EQ.' ')NAMX=NAMQ
	NAMZ=NAMX
	NPG=1
	RA=JPG*RSTJ2
	MPG=10./RA
C  MPG=NUM OF BRACES PER PAGE.
	SPG=10./MPG
C  SPG IS SPACE TO BE SET ABOVE STAFF 0
	IF(LOOKF(NAMX).GE.0)GO TO 88
	TYPE 88,NAMX
	ACCEPT 102,L
	IF(L.EQ.'N')GO TO 103
88	FORMAT(' WRITE OVER FILE ',A5,'????  '$)
1000	KP=1
	JEND=0
C  FLAG FOR PAGE END - WHEN -1
	RT=2
	J=KK
	HGT=HX*2.
	LB=0
	MTR1=-1

	DO 1 K=KK,I
	N=KPN(K)
	IF(Q(N+1).NE.4)GO TO 1
	IF(KA.EQ.0)GO TO 334
	LB=LB+1
C  BAR COUNTER
	IF(NBAR(LC).GT.LB)GO TO 1
C FOR SPECIFIED BARS
	LC=LC+1
	LB=0
	IF(NBAR(LC).NE.0)GO TO 335
	JEND=-1
	LC=LC+1
	GO TO 335
334	IF(Q(N+3).LT.XLINE)GO TO 1
C  FOUND LAST BAR LINE.
335	RX=0
	MTR1=-1
	MTR2=-1
	LL=KPN(K+1)
C TO ADD METER AT END OF BAR
	RS=Q(LL+1)
	IF(RS.LE.4)GO TO 3
	IF(RS.EQ.18)MTR1=LL
C WHAT ABOUT REHRSL NUMS, ETC??
	LL=KPN(K+2)
	RS=Q(LL+1)
	IF(RS.LE.4)GO TO 3
	IF(IPG)GO TO 4011
	IF(Q(LL+2).NE.Q(N+2))GO TO 4111
4011	IF(RS.EQ.18)MTR2=LL
	LL=KPN(K+3)
	IF(IPG)GO TO 4211
	IF(Q(LL+2).NE.Q(N+2))GO TO 4111
4211	IF(Q(LL+1).EQ.18)MTR2=LL
4111	IF(MTR1.GT.0)GO TO 3
	MTR1=MTR2
	MTR2=-1
C IN CASE IT SAW SOMETHING AHEAD OF NEW METER
3	JJ=KP
C PUTS IN STAFF
	RS=3.
	IF(RT.NE.0)GO TO 331
C NEXT FOR BOTTOM STAFF.  PUTS IN SPACER.
	RS=6.
331	IF(IPG)GO TO 411
	HX=8
	RZ=0
	RX=RT
	DO 611 JP=1,JPG
	RT=RSTNUM(JP)
	RS=3
C WD CNT IS RS, HX IS CODE(8), ARRAYS AND JPG WERE SET UP IN MAIN.
	RR=0
	IF(JP.GT.1)GO TO 611
	IF(NAMX.EQ.NAMZ)GO TO 611
	RS=6
	RR=SPG
C  FOR SPACER ON STAFF 0
611	CALL STAFF(RS,HX,RZ,RHGT(JP),RPSZ(JP),RZ,RZ,RR)
	HX=JPG
	RS=4.
	RT=0
	CALL STAFF(2.,RS,RZ,HX,RZ,RZ,RZ,RZ)
	IF(BRACK.NE.0)CALL STAFF(5.,RS,RZ,HX,RZ,RZ,BRACK,RZ)
	RT=RX
	GO TO 511
411	CALL STAFF(RS,8.,0,HGT,RSTJ2,0,0,SP)
	HGT=HGT-HX
511	IF(XLINE.EQ.ZLINE)GO TO 33
	IF(JEND)GO TO 60
C FOR PREMATURE PAGE END
	IF(K.NE.I)GO TO 6
	IF(RT.EQ.0)GO TO 6
60	IF(IPG.EQ.0)GO TO 6
	RX=RT
	RT=0
	CALL STAFF(6.,8.,0,0,0,0,1.,SP)
C  PUTS IN SPACER
	RT=RX
6	IF(JSLUR.EQ.0)GO TO 2333
CC	LL=JSLUR
CC	JSLUR=0
	CALL JSL(JSLUR)
1333	CALL STAFF(5.,5.,0,Q(LL),Q(LL+1),SLSP,Q(LL+3),0)
2333	IF(JSL2.EQ.0)GO TO 333
CC	LL=JSL2
C FOR 2ND SLUR AT END OF LINE.
CC	JSL2=0
	CALL JSL(JSL2)
	GO TO 1333
333	IF(CLEF.EQ.-99)GO TO 33
C  ONLY STAFF FOR FIRST LINE AT TOP.
	RX=10.*RSTJ2
C  THE SPACER
	LA=0
	IF(IPG)GO TO 3011
	LA=JPG
3111	RT=RSTNUM(LA)
	LL=RT
	CLEF=RCLEF(LL)
C GETS CLEF FOR PAGE LAYOUT, RT IS STAFF# IN CALL
	LA=LA-1
3011	CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0)
	IF(SIG.EQ.-99)GO TO 3211
	RS=4.
	R5=SIG
CC	RX=CLEF
CC	IF(R5.LT.50)GO TO 332
CC	RX=IFIX((R5+50.)/100.)
CC	R5=R5-RX*100.
C  CLEF+SIG
332	CALL STAFF(RS,17.,11.0*RSTJ2,0,R5,CLEF,0,0)
	RX=12.*RSTJ2
3211	IF(LA.GT.0)GO TO 3111

33	R4=RA
	R5=Q(N+3)
	RS=0
	R7=RT
	R8=RX
	R9=200.
	LL=0
	L=K-J+1
	CALL PTMOVE(Q,KPN(J))
	RA=R5
31	IF(MTR1)GO TO 231
	LA=0
	IF(IPG)GO TO 5011
	LA=JPG
5111	RT=RSTNUM(LA)
C  PUT METER ON ALL STAVES FOR PAGE LAYOUT
	LA=LA-1
5011	R=200.0+2.23*RSTJ2
	CALL STAFF(Q(MTR1),Q(MTR1+1),R,0,Q(MTR1+5),Q(MTR1+6),0,0)
C  PUTS METER AFTER END OF STAFF
	IF(MTR2)GO TO 5211
	R=200.0+6.7*RSTJ2
	CALL STAFF(Q(MTR2),Q(MTR2+1),R,0,Q(MTR2+5),Q(MTR2+6),0,0)
C  PUTS COMPOSITE METER AFTER END OF STAFF
5211	IF(LA.GT.0)GO TO 5111
231	KB=KL
131	DO 30 NA=KK,K
	KWDS(KP)=KB
	KP=KP+1
	JK=KPN(NA)
	R=Q(JK+1)
	IF(R.EQ.5)GO TO 135
	IF(R.NE.44)GO TO 35
135	RR=Q(JK+6)
	IF(RR.LT.Q(JK+3))GO TO 635
C  NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
	IF(RR.LT.199.)GO TO 37
C CATCHES END OF SLUR AND VARIOUS LINES
635	IF(R.NE.5)GO TO 37
C  TO PUT SLUR ON NEXT LINE.
C*********** IS SOMETHING MISSING HERE????????  4/76
235	IF(JSLUR.NE.0)GO TO 435
CC	JSLUR=JK+4
	JSLUR=JSLX(JK)
	GO TO 535
CC435	JSL2=JK+4
435	JSL2=JSLX(JK)
C FOR 2ND SLUR
535	RR=201
	IF(Q(JK+8).LT.-1)RR=202
	Q(JK+6)=RR
	IF(R.EQ.5)GO TO 30
	GO TO 38

35	IF(R.NE.2)GO TO 36
	IF(Q(JK).LT.6.)GO TO 30
	RR=RIGHT(NA,-1)
	IF(RR.GE.199.)RR=RX
	Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
C  FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
C CENTERS WHOLE REST
	GO TO 30
36	IF(R.NE.3)GO TO 34
CC	RR=Q(JK+5)
CC	IF(Q(JK).LT.3)RR=0
CC	CLEF=AMOD(RR,100.0)
	CLEF=CLEFN(Q,JK)
	IF(IPG)GO TO 30  
	LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
	RCLEF(LL)=CLEF
	GO TO 30
34	IF(R.NE.17)GO TO 37
	SIG=Q(JK+5)
	IF(ABS(SIG).GT.100.)SIG=-99
C  DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX	IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX  CLEF # IN P6 WITH KEY SIGS.
C  NEXT CHANGES CODE NUM BACK TO ORIGINAL
37	IF(R.LT.33)GO TO 30
38	Q(JK+1)=R/11.
30	KB=KPN(NA+1)-KPN(NA)+KB

	CALL PSHFT(KK,K)
	RS=RT
	LL='J'
	R4=0
	R5=200
	NA=L
	L=KP-JJ
	CALL PTMOVE(RN,KWDS(JJ))
	DO 47 JJ2=JJ,KP
	LL=KWDS(JJ2)
	AA=RN(LL+1)
	IF(AA.NE.10.AND.AA.NE.16)GO TO 347
	DO 147 NN=JJ2+1,KP
	MM=KWDS(NN)
	IF(RN(MM+1).NE.16)GO TO 147
C  FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
	IF(RN(MM).EQ.8)GO TO 47
C  JUMP IF POS. IS ALREADY TAKEN CARE OF.
	IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
	IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
	AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C  SETS MINIMUM SPACE.
	IF(RN(MM+3).LT.AA)RN(MM+3)=AA
	GO TO 47
247	IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C  CHECKS VERT. POS.
	AA=RN(LL+4)+7
	IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C  MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
	GO TO 47
147	CONTINUE
	GO TO 47
347	IF(AA.NE.5)GO TO 1047
C TO IMPROVE SLUR PARAMETERS
	R8=RN(LL+8)
	IF(RN(LL).LT.6)R8=0
	IF(R8.GT.0)GO TO 47
C  JUMP IF A BRACKET
	R=RN(LL+6)

	DO 647 NN=JJ2+1,KP
	MM=KWDS(NN)
C  THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
	IF(RN(MM+1).NE.4)GO TO 647
C FIND A BAR LINE
	IF(RN(MM+3).GT.199.)GO TO 647
C  IGNORE LAST BAR OR LINE.
	IF(RN(MM).GT.2)GO TO 647
	AA=ABS(RN(MM+3)-R)
	IF(AA.GT.1.)GO TO 647
	RN(LL+6)=R+4
	GO TO 47
647	CONTINUE

	R7=RN(LL+7)
	R9=R-RN(LL+3)+(R8+1.)*2.
	IF(R9.GT.7)GO TO 47
C  NO WORK NEEDED.  IT'S LONG ENOUGH
	IF(RN(LL).GT.5)RN(LL+8)=-1
	R=1.
	IF(R7.LT.0)R=-R
547	RN(LL+4)=RN(LL+4)+R
	RN(LL+5)=RN(LL+5)+R
C  WERE +AA ↑↑↑↑↑
	RN(LL+7)=R
	GO TO 47
1047	IF(AA.NE.6)GO TO 47
	IF(RN(LL).LT.7)GO TO 47
	IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER.  IT SHOULDN'T MOVE P9 ALWAYS.
47	CONTINUE

	IF(K.EQ.I)GO TO 2
	L=NA
	J=K+1
C  SO IT DOESN'T GO THRU ALL DATA
	RT=RT-1
	XLINE=RA+ZLINE
	IF(ENDLN-XLINE.LT.80.)XLINE=ENDLN
	IF(IPG.EQ.0)GO TO 2  
C  OMIT NEXT FOR PAGE LAYOUT ONLY
10	IF(KL.GT.1700.OR.KP.GT.190.OR.RT.OR.JEND)GO TO 2
1	IF(K.EQ.I)GO TO 3
2	KWDS(KP)=KB
	J=1
	JJ2=KP+1
	JPQ=KB
C  WRITES 1 EXTRA WORD
	CALL PUTFIL(NAMX)
	LCNT=0
	NDPY=0
	CALL FASTOU(RSTFAC,128)
	CALL FASTOU(KWDS,JJ2)
	CALL FASTOU(RN,JPQ)
	TYPE 101,NAMX
	IF(KK.GE.I)CALL EXIT
	NAMX=NAMX+2
	IF(IPG)GO TO 6011
	NPG=NPG+1
	IF(NPG.LE.MPG)GO TO 6011
	NPG=1
C RESET, UPDATE FILENAMES
	NAMX=NAMZ+256
	NAMZ=NAMX
6011	NAMQ=NAMX
	CALL FINFIL
	GO TO 100
101	FORMAT(1XA5)
	END